;
; ; Example
;
; (L-class Gump (L-object)
;   (L-method 'run (times)
;     (unless (>= 0 times)
;       (format t "Run!")
;       (self 'run (- times 1)))))
;
; (Gump 'run 3)
;

(defmacro L-class (class-name (parent-class-name) &rest methods)
  "Creates a child of parent-class-name named class-name with the given methods."
  (let ((target (gensym)))
    `(let ((,target (,parent-class-name 'new ,@methods)))
       (defun ,class-name (&rest msg)
         (apply ,target msg)))))

(defmacro L-method (name paramlist &rest code)
  "Generates an entry to be used as an argument to (L-object 'new)"
  `(cons ,name (lambda (parent self next slots/state slots/methods ,@paramlist)
     (declare (ignorable slots/state)
              (ignorable slots/methods))
     (flet ((self (&rest msg) (apply self msg))
            (next (&rest msg) (apply next msg))
            (parent (&rest msg) (apply parent msg)))
       ,@code))))


;
;
; Bootstrap code for L-object
;


(defun make-L-instance (&key parent self (next parent)
                        (slots/state '(nil) slots/state-supplied-p)
                        slots/methods)
  (let (instance instance-args)
  
	(setq instance

      ;
      ; This is the object right here.
      ; Everything else is scaffolding.
      ;
	  (lambda (&rest msg)
		(let ((method (cdr (assoc (first msg) slots/methods))))
		  (if method
            (apply method (append instance-args (rest msg)))
			(if next
              (apply next msg) ; Send the message up the inheritance chain.
              (apply self (cons 'does-not-understand msg)))))))

    ; Know thyself.
	(unless self
	  (setq self instance)
	  (setq slots/methods (copy-list slots/methods)))

	(setq instance-args
	  (list
	   parent self                      ; non-context specific
	   next slots/state slots/methods)) ; context specific

	; Get next's identical twin
	; And let him know his new daddy.
	(when next
      (setq next (funcall next 'clone parent self))
	  (setf (third instance-args) next))

	; Make a copy of the state
	(when slots/state-supplied-p
	  (setq slots/state (funcall instance 'clone-state slots/state))
	  (setf (fourth instance-args) slots/state))

	instance))


(define-condition does-not-understand-error (error)
  ((target :initarg :target :reader target)
   (msg :initarg :msg :reader msg)))


(let* ((clone-method

         ;
         ; A clone is an identical twin.
         ; Clones may differentiate after 'birth'
         ; but they start out identical.
         ;
         ; The optional arguments to 'clone
         ; are not intended to be part of the
         ; public API.
         ;
         ; This method cannot be overriden.
         ; Override 'clone-state instead.
         ;
         (L-method 'clone (&optional (new-parent parent) new-self)
           (make-L-instance
             :parent new-parent
             :self new-self
             :next next            ; next's clone will be this clone's next
             :slots/state slots/state  ; state will be cloned
             :slots/methods slots/methods))) ; method dictionary will be copied
          
       (L-object (make-L-instance :slots/state nil :slots/methods
         (list clone-method

          ; Will clone the given state.
          ; The state is provided as an argument
          ; to prevent 'leaking' private state
          ; through calls to 'clone-state
          ; in the public API.
          (L-method 'clone-state (state)
            (copy-list state))

          ;
          ; Create a new child.
          ; A child always has all of the methods
          ; of its parent, even if the parent changes.
          ; A child does not have access to its parent's state.
          ;
          ; Please note that while
          ; (funcall obj 'clone)
          ; and
          ; (funcall obj 'new)
          ; will both produce an object that has (initially)
          ; the exact same functionality, they are in fact very different.
          ; The former may be considered the 'uncle' of the latter.
          ;
          (L-method 'new (&rest new-methods)
            (make-L-instance
              :parent self
              :slots/methods
                (nconc
                  (list clone-method)
                  new-methods)))

          (L-method 'does-not-understand (&rest msg)
            (restart-case (error 'does-not-understand-error :target self :msg msg)
              (use-value (value) value)))

          (L-method 'self () self)

          (L-method 'parent () parent)
        
          (L-method 'inherits-from (obj)
            (do ((target (funcall obj 'self))
                 (n self (funcall n 'parent)))
                ((or
                  (eq n target)
                  (eq n nil))
                 n)))))))

  (defun L-object (&rest msg)
    (apply L-object msg)))
